home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Source Code / C / Applications / Moscow ML 1.31 / source code / mosml / src / compiler / Emitcode.sml < prev    next >
Encoding:
Text File  |  1996-07-03  |  7.2 KB  |  225 lines  |  [TEXT/R*ch]
  1. open
  2.   Obj Fnlib Config Mixture Const Instruct Prim
  3.   Opcodes Prim_opc Buffcode Labels Reloc
  4. ;
  5.  
  6. prim_val lshift_    : int -> int -> int = 2 "shift_left";
  7. prim_val rshiftsig_ : int -> int -> int = 2 "shift_right_signed";
  8. prim_val rshiftuns_ : int -> int -> int = 2 "shift_right_unsigned";
  9.  
  10.  
  11. (* Generation of bytecode for .uo files *)
  12.  
  13. fun checkAccessIndex n =
  14.   if n <= maxint_byte then () else
  15.     (msgIBlock 0;
  16.      errPrompt "Too many local variables, unable to compile into bytecode";
  17.      msgEOL();
  18.      msgEBlock();
  19.      raise Toplevel)
  20. ;
  21.  
  22. fun out_bool_test tst =
  23.   fn PTeq    => out tst
  24.    | PTnoteq => out (tst + 1)
  25.    | PTlt    => out (tst + 2)
  26.    | PTgt    => out (tst + 3)
  27.    | PTle    => out (tst + 4)
  28.    | PTge    => out (tst + 5)
  29.    | _       => fatalError "out_bool_test"
  30. ;
  31.  
  32. fun out_int_const i =
  33.   if i >= minint_short andalso i <= maxint_short then
  34.     let val ii1 = i+i+1 in
  35.       if ii1 >= minint_byte andalso ii1 <= maxint_byte then
  36.         (out CONSTBYTE; out (ii1))
  37.       else if ii1 >= minint_short andalso ii1 <= maxint_short then
  38.         (out CONSTSHORT; out_short (ii1))
  39.       else
  40.         (out GETGLOBAL; slot_for_literal(ATOMsc(INTscon i)))
  41.     end
  42.   else
  43.     (out GETGLOBAL; slot_for_literal(ATOMsc(INTscon i)))
  44. ;
  45.  
  46. fun out_tag (CONtag(t,_)) = out t
  47.   | out_tag (EXNtag(name, stamp)) =
  48.       slot_for_tag name stamp
  49. ;
  50.  
  51. fun out_header (n, tag) =
  52. (
  53.   out_tag tag;
  54.   out (lshift_ n 2);
  55.   out (rshiftuns_ n 6);
  56.   out (rshiftuns_ n 14)
  57. );
  58.  
  59. fun emit zams =
  60.   case zams of
  61.       [] => ()
  62.     | Kquote(ATOMsc(INTscon i)) :: C =>
  63.         (out_int_const i;
  64.          emit C)
  65.     | Kquote(ATOMsc(CHARscon c)) :: C =>
  66.         (out_int_const (Char.ord c);
  67.          emit C)
  68.     | Kquote(BLOCKsc(tag, [])) :: C =>
  69.         (case tag of
  70.              CONtag(t,_) =>
  71.                if t < 10 then out (ATOM0 + t) else (out ATOM; out t)
  72.            | EXNtag(name, stamp) =>
  73.                (out ATOM; slot_for_tag name stamp);
  74.          emit C)
  75.     | Kquote sc :: C =>
  76.         (out GETGLOBAL; slot_for_literal sc;
  77.          emit C)
  78.     | Kget_global uid :: C =>
  79.         (out GETGLOBAL;
  80.          slot_for_get_global uid;
  81.          emit C)
  82.     | Kset_global uid :: C =>
  83.         (out SETGLOBAL;
  84.          slot_for_set_global uid;
  85.          emit C)
  86.     | Kaccess n :: C =>
  87.         (checkAccessIndex n;
  88.          if n < 6 then out(ACC0 + n) else (out ACCESS; out n);
  89.          emit C)
  90.     | Kendlet n :: Kendlet p :: C =>
  91.         emit(Kendlet(n+p) :: C)
  92.     | Kendlet 1 :: C =>
  93.         (out ENDLET1; emit C)
  94.     | Kendlet n :: C =>
  95.         (checkAccessIndex n;
  96.          out ENDLET; out n; emit C)
  97.     | Kletrec1 lbl :: C =>
  98.         (out LETREC1; out_label lbl; emit C)
  99.     | Kmakeblock(tag,n) :: C =>
  100.         (if n <= 0 then
  101.            fatalError "emit : Kmakeblock"
  102.          else if n < 5 then
  103.            (out (MAKEBLOCK1 + n - 1);
  104.             out_tag tag)
  105.          else
  106.           (out MAKEBLOCK;
  107.            out_header(n, tag));
  108.          emit C)
  109.     | Klabel lbl :: C =>
  110.         if lbl = Nolabel then fatalError "emit: undefined label" else
  111.           (define_label lbl; emit C)
  112.     | Kclosure lbl :: C =>
  113.         (out CUR; out_label lbl; emit C)
  114.     | Kpushtrap lbl :: C =>
  115.         (out PUSHTRAP; out_label lbl; emit C)
  116.     | Kbranch lbl :: C =>
  117.         (out BRANCH; out_label lbl; emit C)
  118.     | Kbranchif lbl :: C =>
  119.         (out BRANCHIF; out_label lbl; emit C)
  120.     | Kbranchifnot lbl :: C =>
  121.         (out BRANCHIFNOT; out_label lbl; emit C)
  122.     | Kstrictbranchif lbl :: C =>
  123.         (out BRANCHIF; out_label lbl; emit C)
  124.     | Kstrictbranchifnot lbl :: C =>
  125.         (out BRANCHIFNOT; out_label lbl; emit C)
  126.     | Kswitch lblvect :: C =>
  127.         let val len = Array.length lblvect
  128.             val ()  = out SWITCH;
  129.             val ()  = out len;
  130.             val orig = !out_position
  131.         in
  132.           for (fn i => out_label_with_orig orig (Array.sub(lblvect, i)))
  133.               0 (len-1);
  134.           emit C
  135.         end
  136.     | Ktest(tst,lbl) :: C =>
  137.         (case tst of
  138.              Peq_test =>
  139.                (out BRANCHIFEQ; out_label lbl)
  140.            | Pnoteq_test =>
  141.                (out BRANCHIFNEQ; out_label lbl)
  142.            | Pint_test(PTnoteqimm i) =>
  143.                (out PUSH; out PUSH; out_int_const i;
  144.                 out EQ; out POPBRANCHIFNOT; out_label lbl)
  145.            | Pint_test x =>
  146.                (out_bool_test BRANCHIFEQ x; out_label lbl)
  147.            | Pfloat_test(PTnoteqimm f) =>
  148.                (out PUSH; out PUSH; out GETGLOBAL;
  149.                 slot_for_literal (ATOMsc(REALscon f));
  150.                 out EQFLOAT; out POPBRANCHIFNOT; out_label lbl)
  151.            | Pfloat_test x =>
  152.                (out_bool_test EQFLOAT x; out BRANCHIF; out_label lbl)
  153.            | Pstring_test(PTnoteqimm s) =>
  154.                (out PUSH; out PUSH; out GETGLOBAL;
  155.                 slot_for_literal (ATOMsc(STRINGscon s));
  156.                 out EQSTRING; out POPBRANCHIFNOT; out_label lbl)
  157.            | Pstring_test x =>
  158.                (out_bool_test EQSTRING x; out BRANCHIF; out_label lbl)
  159.            | Pnoteqtag_test tag =>
  160.                (out BRANCHIFNEQTAG; out_tag tag; out_label lbl)
  161.          ;
  162.          emit C)
  163.     | Kbranchinterval(low, high, lbl_low, lbl_high) :: C =>
  164.         (out PUSH; out_int_const low; out PUSH;
  165.          if low <> high then out_int_const high else ();
  166.          out BRANCHINTERVAL;
  167.          out_label lbl_low;
  168.          out_label lbl_high;
  169.          emit C)
  170.     | Kprim Pidentity :: C =>
  171.         emit C
  172.     | Kprim p :: C =>
  173.         (case p of
  174.             Pdummy n =>
  175.               (out DUMMY; out n)
  176.           | Ptest tst =>
  177.               (case tst of
  178.                   Peq_test => out EQ
  179.                 | Pnoteq_test => out NEQ
  180.                 | Pint_test tst => out_bool_test EQ tst
  181.                 | Pfloat_test tst => out_bool_test EQFLOAT tst
  182.                 | Pstring_test tst => out_bool_test EQSTRING tst
  183.                 | _ => fatalError "emit : Kprim, Ptest")
  184.           | Patom t =>
  185.               if t < 10 then out (ATOM0 + t) else (out ATOM; out t)
  186.           | Pfield n =>
  187.               if n < 4 then out (GETFIELD0 + n) else (out GETFIELD; out n)
  188.           | Psetfield n =>
  189.               if n < 4 then out (SETFIELD0 + n) else (out SETFIELD; out n)
  190.           | Pccall(name, arity) =>
  191.               (if arity <= 5 then
  192.                  out (C_CALL1 + arity - 1)
  193.                else
  194.                  (out C_CALLN; out arity);
  195.                slot_for_c_prim name)
  196.           | Pfloatprim p =>
  197.               (out FLOATOP;
  198.                out(opcode_for_float_primitive p))
  199.           | p =>
  200.               out(opcode_for_primitive p)
  201.          ;
  202.          emit C)
  203.     | Kpush :: Kget_global uid :: Kapply :: C =>
  204.         (out PUSH_GETGLOBAL_APPLY;
  205.          slot_for_get_global uid;
  206.          emit C)
  207.     | Kpush :: Kget_global uid :: Ktermapply :: C =>
  208.         (out PUSH_GETGLOBAL_APPTERM;
  209.          slot_for_get_global uid;
  210.          emit C)
  211.     | instr :: C =>
  212.         (out (case instr of
  213.                    Kreturn => RETURN
  214.                 |  Kgrab => GRAB
  215.                 |  Kpush => PUSH
  216.                 |  Kpushmark => PUSHMARK
  217.                 |  Klet => LET
  218.                 |  Kapply => APPLY
  219.                 |  Ktermapply => APPTERM
  220.                 |  Kpoptrap => POPTRAP
  221.                 |  Kcheck_signals => CHECK_SIGNALS
  222.                 |  _  => fatalError "emit: should not happen");
  223.         emit C)
  224. ;
  225.